perm filename MET14.LSP[TIM,LSP] blob
sn#715199 filedate 1983-06-16 generic text, type C, neo UTF8
COMMENT ā VALID 00003 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (declare
C00008 00003
C00009 ENDMK
Cā;
(declare
(fasload meter)
(load "metint.lsp")
(setq meter:count-only T))
(declare
(setq local-objects-of-interest
'((mapcan "Mapcans")(funcall "Funcalls")
(mapc "Mapcs")
(list "Lists")(list* "List*s"))))
(meter:meter sccpp
(meter-funs #.(all-objs)
(DEFUN PAIRS (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
NIL-PAIRS)
(mn "PAIR" pair)
((LAMBDA (XXX)
(MAPCAN
#'(LAMBDA (I)
(AND
(COND
(MUST-APPEAR
(MN "Catches" catch)
(*CATCH 'OUT
(MAPC
#'(LAMBDA (I) (COND ((MEMBER (CDR I) MUST-APPEAR)
(MN "Throws" throw)
(*THROW 'OUT T))))
I)))
(T))
(LIST I)))
XXX))
(MAPCAR #'CDR
(COND ((< (LENGTH X)
(+ (COND (NIL-PAIRS 1) (T 0)) (LENGTH Y)))
(PAIRS1 (MAKE-POSSIBILITY-1 X
Y
FUN
APPLY-CONSTRAINTS
CONSTRAINTS
NIL-PAIRS)))
(T (PAIRS2 (MAKE-POSSIBILITY-2 Y
X
FUN
APPLY-CONSTRAINTS
CONSTRAINTS
NIL-PAIRS)))))))
(DEFUN MAKE-POSSIBILITY-1 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
NIL-PAIRS)
(mn "MAKE-POSSIBILITY-1" mp1)
((LAMBDA (N)
((LAMBDA (Q)
(COND
(NIL-PAIRS (MAPC #'(LAMBDA (I) (RPLACD I
(LIST* '(NIL)
(CDR I))))
Q))
(T Q)))
(MAPCAN
#'(LAMBDA (I)
(SETQ N 0)
((LAMBDA (A) (AND A
(OR (NULL CONSTRAINTS)
(NULL APPLY-CONSTRAINTS)
(FUNCALL APPLY-CONSTRAINTS
CONSTRAINTS))
(LIST (LIST* I A))))
(MAPCAN
#'(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
(PROGN (SETQ N (1+ N))
(COND ((OR (NULL FUN)
(FUNCALL FUN I J))
(LIST* N J))))))
Y)))
X)))
0))
(DEFUN MAKE-POSSIBILITY-2 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
NIL-PAIRS)
(mn "MAKE-POSSIBILITY-2" mp2)
((LAMBDA (N)
((LAMBDA (Q)
(COND
(NIL-PAIRS (MAPC #'(LAMBDA (I) (RPLACD I
(LIST* '(NIL)
(CDR I))))
Q))
(Q)))
(MAPCAN
#'(LAMBDA (I)
(SETQ N 0)
((LAMBDA (A) (AND A
(OR (NULL CONSTRAINTS)
(NULL APPLY-CONSTRAINTS)
(FUNCALL APPLY-CONSTRAINTS
CONSTRAINTS))
(LIST (LIST* I A))))
(MAPCAN
#'(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
(PROGN (SETQ N (1+ N))
(COND ((OR (NULL FUN)
(FUNCALL FUN J I))
(LIST* N J))))))
Y)))
X)))
0))
(DEFUN PAIRS1 (L)
(mn "PAIRS1" pairs1)
(COND
((NULL L) '((NIL)))
(T
((LAMBDA (CAND POSS)
(MAPCAN
#'(LAMBDA (PAIRS)
((LAMBDA (AVOID ANS)
(MAPCAN
#'(LAMBDA (I)
((LAMBDA (Q) (COND (Q (NCONS Q))))
(COND ((CAR (MEMBER (CAR I)
AVOID))
(LIST* AVOID ANS))
(T (LIST* (LIST* (CAR I)
AVOID)
(LIST* CAND
(CDR I))
ANS)))))
POSS))
(CAR PAIRS)
(CDR PAIRS)))
(PAIRS1 (CDR L))))
(CAAR L)
(progn
(mn "Cars" car 1)
(mn "Cdrs" cdr 1)
(CDAR L))))))
(DEFUN PAIRS2 (L)
(mn "PAIRS1" pairs1)
(COND
((NULL L) '((NIL)))
(T
((LAMBDA (CAND POSS)
(MAPCAN
#'(LAMBDA (PAIRS)
((LAMBDA (AVOID ANS)
(MAPCAN
#'(LAMBDA (I)
((LAMBDA (Q) (COND (Q (NCONS Q))))
(COND ((CAR (MEMBER (CAR I)
AVOID))
(LIST* AVOID ANS))
(T (LIST* (LIST* (CAR I)
AVOID)
(LIST* (CDR I)
CAND)
ANS)))))
POSS))
(CAR PAIRS)
(CDR PAIRS)))
(PAIRS2 (CDR L))))
(CAAR L)
(progn
(mn "Cars" car 1)
(mn "Cdrs" cdr 1)
(CDAR L))))))))
(declare (special a b))
(setq a '(
(1 2)
(7 8)
(9 0)
(a b c)
(a b c)
(d e f)
(d e f)
(g h i)
(g h i)
(j k l)
(m n o)
(p q r)
))
(setq b '(
(a b c)
(j k l)
(d e f)
(p q r)
(g h i)
(9 0)
(a b c)
(p q r)
(7 8)
(j k l)
(2 1)
(3 2)
(8 7)
(9 8)
(0 9)
(m n o)
(d e f)
(j k l)
(m n o)
(d e f)
(p q r)
(g h i)
))